home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / demo / X11 / mdraw / mdraw.hs next >
Encoding:
Text File  |  1994-09-27  |  2.6 KB  |  83 lines  |  [TEXT/YHS2]
  1. module MDraw where
  2.  
  3. import Xlib 
  4.  
  5. mapIO :: (a -> IO b) -> [a] -> IO [b]
  6.  
  7. mapIO f []     = return []
  8. mapIO f (x:xs) = f x >>= \ y -> 
  9.                  mapIO f xs >>= \ ys -> 
  10.          return (y:ys)
  11.  
  12. map2IO :: (a -> b -> IO c) -> [a] -> [b] -> IO [c]
  13.  
  14. map2IO f [] []         = return []
  15. map2IO f (x:xs) (z:zs) = f x z >>= \ y -> 
  16.                  map2IO f xs zs >>= \ ys -> 
  17.                  return (y:ys)
  18.  
  19. xGetEventMul              :: XMArray XDisplay -> IO (Int, XEvent)
  20. xGetEventMul displays = 
  21.   let n_displays = xMArrayLength displays
  22.       loop :: Int -> IO (Int, XEvent)
  23.       loop i = if i == n_displays then loop 0
  24.                else xMArrayLookup displays i >>= \ display ->
  25.                     xDisplayForceOutput display >>
  26.                     xEventListen display >>= \ n_events ->
  27.                     if n_events == 0 then loop (i + 1)
  28.                     else xGetEvent display >>= \ event ->
  29.                          return (i, event)
  30.   in loop 0
  31.  
  32. -- takes a list of host names
  33.  
  34. mdraw :: [String] -> IO ()
  35. mdraw hosts =
  36.   mapIO xOpenDisplay hosts >>= \ displays ->
  37.   let screens = map (head . xDisplayRoots) displays
  38.       fg_colors = map xScreenBlackPixel screens
  39.       bg_colors = map xScreenWhitePixel screens
  40.       roots = map xScreenRoot screens
  41.   in
  42.   map2IO (\ root color -> 
  43.               xCreateWindow root 
  44.                             (XRect 100 100 400 400)
  45.                             [XWinBackground color,
  46.                      XWinEventMask (XEventMask [XButtonMotion, 
  47.                                                         XButtonPress])])
  48.          roots
  49.          bg_colors 
  50.   >>= \windows ->
  51.   mapIO xMapWindow windows >>
  52.   map2IO xCreateGcontext 
  53.         (map XDrawWindow roots) 
  54.         (map (\ color -> [XGCForeground color]) fg_colors)
  55.   >>= \ gcontexts ->
  56.   xMArrayCreate displays >>= \ displayArr ->
  57.   let
  58.     handleEvent lasts =
  59.       xGetEventMul displayArr >>= \ (idx, event) ->
  60.         let pos = xEventPos event
  61.     in
  62.     case (xEventType event) of
  63.           XButtonPressEvent  -> 
  64.             xMArrayUpdate lasts idx pos >>
  65.             handleEvent lasts
  66.           XMotionNotifyEvent ->
  67.             xMArrayLookup lasts idx >>= \ last -> 
  68.             map2IO (\ window gcontext -> xDrawLine (XDrawWindow window) 
  69.                                                     gcontext 
  70.                                                     last 
  71.                                                     pos)
  72.                    windows
  73.                    gcontexts
  74.             >>
  75.             xMArrayUpdate lasts idx pos >>
  76.             handleEvent lasts
  77.           _                  -> handleEvent lasts
  78.   in
  79.   xMArrayCreate (map (\ _ -> XPoint 0 0) hosts) >>= \ lasts ->
  80.   handleEvent lasts >>
  81.   return ()
  82.  
  83.